Supercompiler 1997

home *** CD-ROM | disk | FTP | other *** search

/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / extctrls.pas < prev next >

Wrap

Pascal/Delphi Source File | 1997-01-29 | 60.5 KB | 2,356 lines

{*******************************************************} { } { Delphi Visual Component Library } { } { Copyright (c) 1995,97 Borland International } { } {*******************************************************} unit ExtCtrls; {$S-,W-,R-} {$C PRELOAD} interface uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics, StdCtrls; type TShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare, stEllipse, stCircle); TShape = class(TGraphicControl) private FPen: TPen; FBrush: TBrush; FShape: TShapeType; procedure SetBrush(Value: TBrush); procedure SetPen(Value: TPen); procedure SetShape(Value: TShapeType); protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published procedure StyleChanged(Sender: TObject); property Align; property Brush: TBrush read FBrush write SetBrush; property DragCursor; property DragMode; property Enabled; property ParentShowHint; property Pen: TPen read FPen write SetPen; property Shape: TShapeType read FShape write SetShape default stRectangle; property ShowHint; property Visible; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; end; TPaintBox = class(TGraphicControl) private FOnPaint: TNotifyEvent; protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; property Canvas; published property Align; property Color; property DragCursor; property DragMode; property Enabled; property Font; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property Visible; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; property OnStartDrag; end; TImage = class(TGraphicControl) private FPicture: TPicture; FOnProgress: TProgressEvent; FAutoSize: Boolean; FStretch: Boolean; FCenter: Boolean; FIncrementalDisplay: Boolean; function GetCanvas: TCanvas; procedure PictureChanged(Sender: TObject); procedure SetAutoSize(Value: Boolean); procedure SetCenter(Value: Boolean); procedure SetPicture(Value: TPicture); procedure SetStretch(Value: Boolean); protected function DestRect: TRect; function GetPalette: HPALETTE; override; procedure Paint; override; procedure Progress(Sender: TObject; Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Canvas: TCanvas read GetCanvas; published property Align; property AutoSize: Boolean read FAutoSize write SetAutoSize default False; property Center: Boolean read FCenter write SetCenter default False; property DragCursor; property DragMode; property Enabled; property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay; property ParentShowHint; property Picture: TPicture read FPicture write SetPicture; property PopupMenu; property ShowHint; property Stretch: Boolean read FStretch write SetStretch default False; property Visible; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnProgress: TProgressEvent read FOnProgress write FOnProgress; property OnStartDrag; end; TBevelStyle = (bsLowered, bsRaised); TBevelShape = (bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine, bsRightLine); TBevel = class(TGraphicControl) private FStyle: TBevelStyle; FShape: TBevelShape; procedure SetStyle(Value: TBevelStyle); procedure SetShape(Value: TBevelShape); protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; published property Align; property ParentShowHint; property Shape: TBevelShape read FShape write SetShape default bsBox; property ShowHint; property Style: TBevelStyle read FStyle write SetStyle default bsLowered; property Visible; end; TTimer = class(TComponent) private FInterval: Cardinal; FWindowHandle: HWND; FOnTimer: TNotifyEvent; FEnabled: Boolean; procedure UpdateTimer; procedure SetEnabled(Value: Boolean); procedure SetInterval(Value: Cardinal); procedure SetOnTimer(Value: TNotifyEvent); procedure WndProc(var Msg: TMessage); protected procedure Timer; dynamic; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Enabled: Boolean read FEnabled write SetEnabled default True; property Interval: Cardinal read FInterval write SetInterval default 1000; property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer; end; TPanelBevel = (bvNone, bvLowered, bvRaised); TBevelWidth = 1..MaxInt; TBorderWidth = 0..MaxInt; TCustomPanel = class(TCustomControl) private FBevelInner: TPanelBevel; FBevelOuter: TPanelBevel; FBevelWidth: TBevelWidth; FBorderWidth: TBorderWidth; FBorderStyle: TBorderStyle; FFullRepaint: Boolean; FLocked: Boolean; FOnResize: TNotifyEvent; FAlignment: TAlignment; procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED; procedure CMIsToolControl(var Message: TMessage); message CM_ISTOOLCONTROL; procedure WMSize(var Message: TWMSize); message WM_SIZE; procedure SetAlignment(Value: TAlignment); procedure SetBevelInner(Value: TPanelBevel); procedure SetBevelOuter(Value: TPanelBevel); procedure SetBevelWidth(Value: TBevelWidth); procedure SetBorderWidth(Value: TBorderWidth); procedure SetBorderStyle(Value: TBorderStyle); protected procedure CreateParams(var Params: TCreateParams); override; procedure AlignControls(AControl: TControl; var Rect: TRect); override; procedure Paint; override; procedure Resize; dynamic; property Alignment: TAlignment read FAlignment write SetAlignment default taCenter; property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone; property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvRaised; property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1; property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0; property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone; property Color default clBtnFace; property FullRepaint: Boolean read FFullRepaint write FFullRepaint default True; property Locked: Boolean read FLocked write FLocked default False; property ParentColor default False; property OnResize: TNotifyEvent read FOnResize write FOnResize; public constructor Create(AOwner: TComponent); override; end; TPanel = class(TCustomPanel) published property Align; property Alignment; property BevelInner; property BevelOuter; property BevelWidth; property BorderWidth; property BorderStyle; property DragCursor; property DragMode; property Enabled; property Caption; property Color; property Ctl3D; property Font; property Locked; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property TabStop; property Visible; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnResize; property OnStartDrag; end; TPage = class(TCustomControl) private procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; protected procedure ReadState(Reader: TReader); override; procedure Paint; override; public constructor Create(AOwner: TComponent); override; published property Caption; property Height stored False; property TabOrder stored False; property Visible stored False; property Width stored False; end; TNotebook = class(TCustomControl) private FPageList: TList; FAccess: TStrings; FPageIndex: Integer; FOnPageChanged: TNotifyEvent; procedure SetPages(Value: TStrings); procedure SetActivePage(const Value: string); function GetActivePage: string; procedure SetPageIndex(Value: Integer); protected procedure CreateParams(var Params: TCreateParams); override; function GetChildOwner: TComponent; override; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; procedure ReadState(Reader: TReader); override; procedure ShowControl(AControl: TControl); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property ActivePage: string read GetActivePage write SetActivePage stored False; property Align; property Color; property Ctl3D; property DragCursor; property DragMode; property Font; property Enabled; property PageIndex: Integer read FPageIndex write SetPageIndex default 0; property Pages: TStrings read FAccess write SetPages stored False; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property TabStop; property Visible; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnPageChanged: TNotifyEvent read FOnPageChanged write FOnPageChanged; property OnStartDrag; end; { THeader Purpose - Creates sectioned visual header that allows each section to be resized with the mouse. Features - This is a design-interactive control. In design mode, the sections are named using the string-list editor. Each section can now be manually resized using the right mouse button the grab the divider and drag to the new size. Changing the section list at design (or even run-time), will attempt to maintain the section widths for sections that have not been changed. Properties: Align - Standard property. AllowResize - If True, the control allows run-time mouse resizing of the sections. BorderStyle - Turns the border on and off. Font - Standard property. Sections - A special string-list that contains the section text. ParentFont - Standard property. OnSizing - Event called for each mouse move during a section resize operation. OnSized - Event called once the size operation is complete. SectionWidth - Array property allowing run-time getting and setting of each section's width. } TSectionEvent = procedure(Sender: TObject; ASection, AWidth: Integer) of object; THeader = class(TCustomControl) private FSections: TStrings; FHitTest: TPoint; FCanResize: Boolean; FAllowResize: Boolean; FBorderStyle: TBorderStyle; FResizeSection: Integer; FMouseOffset: Integer; FOnSizing: TSectionEvent; FOnSized: TSectionEvent; procedure SetBorderStyle(Value: TBorderStyle); procedure FreeSections; procedure SetSections(Strings: TStrings); function GetWidth(X: Integer): Integer; procedure SetWidth(X: Integer; Value: Integer); procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR; procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; protected procedure Paint; override; procedure CreateParams(var Params: TCreateParams); override; procedure Sizing(ASection, AWidth: Integer); dynamic; procedure Sized(ASection, AWidth: Integer); dynamic; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property SectionWidth[X: Integer]: Integer read GetWidth write SetWidth; published property Align; property AllowResize: Boolean read FAllowResize write FAllowResize default True; property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle; property Enabled; property Font; property ParentFont; property ParentShowHint; property PopupMenu; property Sections: TStrings read FSections write SetSections; property ShowHint; property TabOrder; property TabStop; property Visible; property OnSizing: TSectionEvent read FOnSizing write FOnSizing; property OnSized: TSectionEvent read FOnSized write FOnSized; end; TCustomRadioGroup = class(TCustomGroupBox) private FButtons: TList; FItems: TStrings; FItemIndex: Integer; FColumns: Integer; FReading: Boolean; FUpdating: Boolean; procedure ArrangeButtons; procedure ButtonClick(Sender: TObject); procedure ItemsChange(Sender: TObject); procedure SetButtonCount(Value: Integer); procedure SetColumns(Value: Integer); procedure SetItemIndex(Value: Integer); procedure SetItems(Value: TStrings); procedure UpdateButtons; procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; procedure WMSize(var Message: TWMSize); message WM_SIZE; protected procedure ReadState(Reader: TReader); override; function CanModify: Boolean; virtual; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; property Columns: Integer read FColumns write SetColumns default 1; property ItemIndex: Integer read FItemIndex write SetItemIndex default -1; property Items: TStrings read FItems write SetItems; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; TRadioGroup = class(TCustomRadioGroup) published property Align; property Caption; property Color; property Columns; property Ctl3D; property DragCursor; property DragMode; property Enabled; property Font; property ItemIndex; property Items; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property TabStop; property Visible; property OnClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnStartDrag; end; NaturalNumber = 1..High(Integer); TSplitter = class(TGraphicControl) private FLineDC: HDC; FDownPos: TPoint; FSplit: Integer; FMinSize: NaturalNumber; FMaxSize: Integer; FControl: TControl; FNewSize: Integer; FActiveControl: TWinControl; FOldKeyDown: TKeyEvent; FBeveled: Boolean; FLineVisible: Boolean; FOnMoved: TNotifyEvent; procedure AllocateLineDC; procedure DrawLine; procedure ReleaseLineDC; procedure UpdateSize(X, Y: Integer); procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure SetBeveled(Value: Boolean); protected procedure Paint; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure StopSizing; public constructor Create(AOwner: TComponent); override; published property Align default alLeft; property Beveled: Boolean read FBeveled write SetBeveled default True; property Color; property MinSize: NaturalNumber read FMinSize write FMinSize default 30; property ParentColor; property OnMoved: TNotifyEvent read FOnMoved write FOnMoved; end; procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor; Width: Integer); implementation uses Consts; { Utility routines } procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor; Width: Integer); procedure DoRect; var TopRight, BottomLeft: TPoint; begin with Canvas, Rect do begin TopRight.X := Right; TopRight.Y := Top; BottomLeft.X := Left; BottomLeft.Y := Bottom; Pen.Color := TopColor; PolyLine([BottomLeft, TopLeft, TopRight]); Pen.Color := BottomColor; Dec(BottomLeft.X); PolyLine([TopRight, BottomRight, BottomLeft]); end; end; begin Canvas.Pen.Width := 1; Dec(Rect.Bottom); Dec(Rect.Right); while Width > 0 do begin Dec(Width); DoRect; InflateRect(Rect, -1, -1); end; Inc(Rect.Bottom); Inc(Rect.Right); end; { TShape } constructor TShape.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csReplicatable]; Width := 65; Height := 65; FPen := TPen.Create; FPen.OnChange := StyleChanged; FBrush := TBrush.Create; FBrush.OnChange := StyleChanged; end; destructor TShape.Destroy; begin FPen.Free; FBrush.Free; inherited Destroy; end; procedure TShape.Paint; var X, Y, W, H, S: Integer; begin with Canvas do begin Pen := FPen; Brush := FBrush; X := Pen.Width div 2; Y := X; W := Width - Pen.Width + 1; H := Height - Pen.Width + 1; if Pen.Width = 0 then begin Dec(W); Dec(H); end; if W < H then S := W else S := H; if FShape in [stSquare, stRoundSquare, stCircle] then begin Inc(X, (W - S) div 2); Inc(Y, (H - S) div 2); W := S; H := S; end; case FShape of stRectangle, stSquare: Rectangle(X, Y, X + W, Y + H); stRoundRect, stRoundSquare: RoundRect(X, Y, X + W, Y + H, S div 4, S div 4); stCircle, stEllipse: Ellipse(X, Y, X + W, Y + H); end; end; end; procedure TShape.StyleChanged(Sender: TObject); begin Invalidate; end; procedure TShape.SetBrush(Value: TBrush); begin FBrush.Assign(Value); end; procedure TShape.SetPen(Value: TPen); begin FPen.Assign(Value); end; procedure TShape.SetShape(Value: TShapeType); begin if FShape <> Value then begin FShape := Value; Invalidate; end; end; { TPaintBox } constructor TPaintBox.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csReplicatable]; Width := 105; Height := 105; end; procedure TPaintBox.Paint; begin Canvas.Font := Font; Canvas.Brush.Color := Color; if csDesigning in ComponentState then with Canvas do begin Pen.Style := psDash; Brush.Style := bsClear; Rectangle(0, 0, Width, Height); end; if Assigned(FOnPaint) then FOnPaint(Self); end; { TImage } constructor TImage.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csReplicatable]; FPicture := TPicture.Create; FPicture.OnChange := PictureChanged; FPicture.OnProgress := Progress; Height := 105; Width := 105; end; destructor TImage.Destroy; begin FPicture.Free; inherited Destroy; end; function TImage.GetPalette: HPALETTE; begin Result := 0; if FPicture.Graphic <> nil then Result := FPicture.Graphic.Palette; end; function TImage.DestRect: TRect; begin if Stretch then Result := ClientRect else if Center then Result := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2, Picture.Width, Picture.Height) else Result := Rect(0, 0, Picture.Width, Picture.Height); end; procedure TImage.Paint; begin if csDesigning in ComponentState then with inherited Canvas do begin Pen.Style := psDash; Brush.Style := bsClear; Rectangle(0, 0, Width, Height); end; with inherited Canvas do StretchDraw(DestRect, Picture.Graphic); end; procedure TImage.Progress(Sender: TObject; Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); begin if FIncrementalDisplay and RedrawNow then Paint; if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg); end; function TImage.GetCanvas: TCanvas; var Bitmap: TBitmap; begin if Picture.Graphic = nil then begin Bitmap := TBitmap.Create; try Bitmap.Width := Width; Bitmap.Height := Height; Picture.Graphic := Bitmap; finally Bitmap.Free; end; end; if Picture.Graphic is TBitmap then Result := TBitmap(Picture.Graphic).Canvas else raise EInvalidOperation.Create(SImageCanvasNeedsBitmap); end; procedure TImage.SetAutoSize(Value: Boolean); begin FAutoSize := Value; PictureChanged(Self); end; procedure TImage.SetCenter(Value: Boolean); begin if FCenter <> Value then begin FCenter := Value; PictureChanged(Self); end; end; procedure TImage.SetPicture(Value: TPicture); begin FPicture.Assign(Value); end; procedure TImage.SetStretch(Value: Boolean); begin if Value <> FStretch then begin FStretch := Value; PictureChanged(Self); end; end; procedure TImage.PictureChanged(Sender: TObject); var ParentForm: TCustomForm; begin if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then SetBounds(Left, Top, Picture.Width, Picture.Height); if Picture.Graphic <> nil then begin if (not Picture.Graphic.Transparent) and (Picture.Width >= Width) and (Picture.Height >= Height) then ControlStyle := ControlStyle + [csOpaque] else ControlStyle := ControlStyle - [csOpaque]; if Visible and (not (csLoading in ComponentState)) and Picture.Graphic.PaletteModified then begin ParentForm := GetParentForm(Self); if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0); Picture.Graphic.PaletteModified := False; end; end else ControlStyle := ControlStyle - [csOpaque]; Invalidate; end; { TBevel } constructor TBevel.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csReplicatable]; FStyle := bsLowered; FShape := bsBox; Width := 50; Height := 50; end; procedure TBevel.SetStyle(Value: TBevelStyle); begin if Value <> FStyle then begin FStyle := Value; Invalidate; end; end; procedure TBevel.SetShape(Value: TBevelShape); begin if Value <> FShape then begin FShape := Value; Invalidate; end; end; procedure TBevel.Paint; var Color1, Color2: TColor; Temp: TColor; procedure BevelRect(const R: TRect); begin with Canvas do begin Pen.Color := Color1; PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top), Point(R.Right, R.Top)]); Pen.Color := Color2; PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom), Point(R.Left, R.Bottom)]); end; end; procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer); begin with Canvas do begin Pen.Color := C; MoveTo(X1, Y1); LineTo(X2, Y2); end; end; begin with Canvas do begin Pen.Width := 1; if FStyle = bsLowered then begin Color1 := clBtnShadow; Color2 := clBtnHighlight; end else begin Color1 := clBtnHighlight; Color2 := clBtnShadow; end; case FShape of bsBox: BevelRect(Rect(0, 0, Width - 1, Height - 1)); bsFrame: begin Temp := Color1; Color1 := Color2; BevelRect(Rect(1, 1, Width - 1, Height - 1)); Color2 := Temp; Color1 := Temp; BevelRect(Rect(0, 0, Width - 2, Height - 2)); end; bsTopLine: begin BevelLine(Color1, 0, 0, Width, 0); BevelLine(Color2, 0, 1, Width, 1); end; bsBottomLine: begin BevelLine(Color1, 0, Height - 2, Width, Height - 2); BevelLine(Color2, 0, Height - 1, Width, Height - 1); end; bsLeftLine: begin BevelLine(Color1, 0, 0, 0, Height); BevelLine(Color2, 1, 0, 1, Height); end; bsRightLine: begin BevelLine(Color1, Width - 2, 0, Width - 2, Height); BevelLine(Color2, Width - 1, 0, Width - 1, Height); end; end; end; end; { TTimer } constructor TTimer.Create(AOwner: TComponent); begin inherited Create(AOwner); FEnabled := True; FInterval := 1000; FWindowHandle := AllocateHWnd(WndProc); end; destructor TTimer.Destroy; begin FEnabled := False; UpdateTimer; DeallocateHWnd(FWindowHandle); inherited Destroy; end; procedure TTimer.WndProc(var Msg: TMessage); begin with Msg do if Msg = WM_TIMER then try Timer; except Application.HandleException(Self); end else Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam); end; procedure TTimer.UpdateTimer; begin KillTimer(FWindowHandle, 1); if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then if SetTimer(FWindowHandle, 1, FInterval, nil) = 0 then raise EOutOfResources.Create(SNoTimers); end; procedure TTimer.SetEnabled(Value: Boolean); begin if Value <> FEnabled then begin FEnabled := Value; UpdateTimer; end; end; procedure TTimer.SetInterval(Value: Cardinal); begin if Value <> FInterval then begin FInterval := Value; UpdateTimer; end; end; procedure TTimer.SetOnTimer(Value: TNotifyEvent); begin FOnTimer := Value; UpdateTimer; end; procedure TTimer.Timer; begin if Assigned(FOnTimer) then FOnTimer(Self); end; { TCustomPanel } constructor TCustomPanel.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csSetCaption, csOpaque, csDoubleClicks, csReplicatable]; Width := 185; Height := 41; FAlignment := taCenter; BevelOuter := bvRaised; BevelWidth := 1; FBorderStyle := bsNone; Color := clBtnFace; FFullRepaint := True; end; procedure TCustomPanel.CreateParams(var Params: TCreateParams); const BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER); begin inherited CreateParams(Params); with Params do begin Style := Style or BorderStyles[FBorderStyle]; if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin Style := Style and not WS_BORDER; ExStyle := ExStyle or WS_EX_CLIENTEDGE; end; WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); end; end; procedure TCustomPanel.CMTextChanged(var Message: TMessage); begin Invalidate; end; procedure TCustomPanel.CMCtl3DChanged(var Message: TMessage); begin if NewStyleControls and (FBorderStyle = bsSingle) then RecreateWnd; inherited; end; procedure TCustomPanel.CMIsToolControl(var Message: TMessage); begin if not FLocked then Message.Result := 1; end; procedure TCustomPanel.Resize; begin if FullRepaint then Invalidate; if Assigned(FOnResize) then FOnResize(Self); end; procedure TCustomPanel.WMSize(var Message: TWMSize); begin inherited; if not (csLoading in ComponentState) then Resize; end; procedure TCustomPanel.AlignControls(AControl: TControl; var Rect: TRect); var BevelSize: Integer; begin BevelSize := BorderWidth; if BevelOuter <> bvNone then Inc(BevelSize, BevelWidth); if BevelInner <> bvNone then Inc(BevelSize, BevelWidth); InflateRect(Rect, -BevelSize, -BevelSize); inherited AlignControls(AControl, Rect); end; procedure TCustomPanel.Paint; var Rect: TRect; TopColor, BottomColor: TColor; FontHeight: Integer; const Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER); procedure AdjustColors(Bevel: TPanelBevel); begin TopColor := clBtnHighlight; if Bevel = bvLowered then TopColor := clBtnShadow; BottomColor := clBtnShadow; if Bevel = bvLowered then BottomColor := clBtnHighlight; end; begin Rect := GetClientRect; if BevelOuter <> bvNone then begin AdjustColors(BevelOuter); Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); end; Frame3D(Canvas, Rect, Color, Color, BorderWidth); if BevelInner <> bvNone then begin AdjustColors(BevelInner); Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth); end; with Canvas do begin Brush.Color := Color; FillRect(Rect); Brush.Style := bsClear; Font := Self.Font; FontHeight := TextHeight('W'); with Rect do begin Top := ((Bottom + Top) - FontHeight) div 2; Bottom := Top + FontHeight; end; DrawText(Handle, PChar(Caption), -1, Rect, (DT_EXPANDTABS or DT_VCENTER) or Alignments[FAlignment]); end; end; procedure TCustomPanel.SetAlignment(Value: TAlignment); begin FAlignment := Value; Invalidate; end; procedure TCustomPanel.SetBevelInner(Value: TPanelBevel); begin FBevelInner := Value; Realign; Invalidate; end; procedure TCustomPanel.SetBevelOuter(Value: TPanelBevel); begin FBevelOuter := Value; Realign; Invalidate; end; procedure TCustomPanel.SetBevelWidth(Value: TBevelWidth); begin FBevelWidth := Value; Realign; Invalidate; end; procedure TCustomPanel.SetBorderWidth(Value: TBorderWidth); begin FBorderWidth := Value; Realign; Invalidate; end; procedure TCustomPanel.SetBorderStyle(Value: TBorderStyle); begin if FBorderStyle <> Value then begin FBorderStyle := Value; RecreateWnd; end; end; { TPageAccess } type TPageAccess = class(TStrings) private PageList: TList; Notebook: TNotebook; protected function GetCount: Integer; override; function Get(Index: Integer): string; override; procedure Put(Index: Integer; const S: string); override; function GetObject(Index: Integer): TObject; override; procedure SetUpdateState(Updating: Boolean); override; public constructor Create(APageList: TList; ANotebook: TNotebook); procedure Clear; override; procedure Delete(Index: Integer); override; procedure Insert(Index: Integer; const S: string); override; procedure Move(CurIndex, NewIndex: Integer); override; end; constructor TPageAccess.Create(APageList: TList; ANotebook: TNotebook); begin inherited Create; PageList := APageList; Notebook := ANotebook; end; function TPageAccess.GetCount: Integer; begin Result := PageList.Count; end; function TPageAccess.Get(Index: Integer): string; begin Result := TPage(PageList[Index]).Caption; end; procedure TPageAccess.Put(Index: Integer; const S: string); begin TPage(PageList[Index]).Caption := S; end; function TPageAccess.GetObject(Index: Integer): TObject; begin Result := PageList[Index]; end; procedure TPageAccess.SetUpdateState(Updating: Boolean); begin { do nothing } end; procedure TPageAccess.Clear; var I: Integer; begin for I := 0 to PageList.Count - 1 do TPage(PageList[I]).Free; PageList.Clear; end; procedure TPageAccess.Delete(Index: Integer); var Form: TCustomForm; begin TPage(PageList[Index]).Free; PageList.Delete(Index); NoteBook.PageIndex := 0; if csDesigning in NoteBook.ComponentState then begin Form := GetParentForm(NoteBook); if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified; end; end; procedure TPageAccess.Insert(Index: Integer; const S: string); var Page: TPage; Form: TCustomForm; begin Page := TPage.Create(Notebook); with Page do begin Parent := Notebook; Caption := S; end; PageList.Insert(Index, Page); NoteBook.PageIndex := Index; if csDesigning in NoteBook.ComponentState then begin Form := GetParentForm(NoteBook); if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified; end; end; procedure TPageAccess.Move(CurIndex, NewIndex: Integer); var AObject: TObject; begin if CurIndex <> NewIndex then begin AObject := PageList[CurIndex]; PageList[CurIndex] := PageList[NewIndex]; PageList[NewIndex] := AObject; end; end; { TPage } constructor TPage.Create(AOwner: TComponent); begin inherited Create(AOwner); Visible := False; ControlStyle := ControlStyle + [csAcceptsControls]; Align := alClient; end; procedure TPage.Paint; begin inherited Paint; if csDesigning in ComponentState then with Canvas do begin Pen.Style := psDash; Brush.Style := bsClear; Rectangle(0, 0, Width, Height); end; end; procedure TPage.ReadState(Reader: TReader); begin if Reader.Parent is TNotebook then TNotebook(Reader.Parent).FPageList.Add(Self); inherited ReadState(Reader); end; procedure TPage.WMNCHitTest(var Message: TWMNCHitTest); begin if not (csDesigning in ComponentState) then Message.Result := HTTRANSPARENT else inherited; end; { TNotebook } var Registered: Boolean = False; constructor TNotebook.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 150; Height := 150; FPageList := TList.Create; FAccess := TPageAccess.Create(FPageList, Self); FPageIndex := -1; FAccess.Add(SDefault); PageIndex := 0; Exclude(FComponentStyle, csInheritable); if not Registered then begin Classes.RegisterClasses([TPage]); Registered := True; end; end; destructor TNotebook.Destroy; begin FAccess.Free; FPageList.Free; inherited Destroy; end; procedure TNotebook.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); with Params do begin Style := Style or WS_CLIPCHILDREN; WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); end; end; function TNotebook.GetChildOwner: TComponent; begin Result := Self; end; procedure TNotebook.GetChildren(Proc: TGetChildProc; Root: TComponent); var I: Integer; begin for I := 0 to FPageList.Count - 1 do Proc(TControl(FPageList[I])); end; procedure TNotebook.ReadState(Reader: TReader); begin Pages.Clear; inherited ReadState(Reader); if (FPageIndex <> -1) and (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then with TPage(FPageList[FPageIndex]) do begin BringToFront; Visible := True; Align := alClient; end else FPageIndex := -1; end; procedure TNotebook.ShowControl(AControl: TControl); var I: Integer; begin for I := 0 to FPageList.Count - 1 do if FPageList[I] = AControl then begin SetPageIndex(I); Exit; end; inherited ShowControl(AControl); end; procedure TNotebook.SetPages(Value: TStrings); begin FAccess.Assign(Value); end; procedure TNotebook.SetPageIndex(Value: Integer); var ParentForm: TCustomForm; begin if csLoading in ComponentState then begin FPageIndex := Value; Exit; end; if (Value <> FPageIndex) and (Value >= 0) and (Value < FPageList.Count) then begin ParentForm := GetParentForm(Self); if ParentForm <> nil then if ContainsControl(ParentForm.ActiveControl) then ParentForm.ActiveControl := Self; with TPage(FPageList[Value]) do begin BringToFront; Visible := True; Align := alClient; end; if (FPageIndex >= 0) and (FPageIndex < FPageList.Count) then TPage(FPageList[FPageIndex]).Visible := False; FPageIndex := Value; if ParentForm <> nil then if ParentForm.ActiveControl = Self then SelectFirst; if Assigned(FOnPageChanged) then FOnPageChanged(Self); end; end; procedure TNotebook.SetActivePage(const Value: string); begin SetPageIndex(FAccess.IndexOf(Value)); end; function TNotebook.GetActivePage: string; begin Result := FAccess[FPageIndex]; end; { THeaderStrings } const DefaultSectionWidth = 75; type PHeaderSection = ^THeaderSection; THeaderSection = record FObject: TObject; Width: Integer; Title: string; end; type THeaderStrings = class(TStrings) private FHeader: THeader; FList: TList; procedure ReadData(Reader: TReader); procedure WriteData(Writer: TWriter); protected procedure DefineProperties(Filer: TFiler); override; function Get(Index: Integer): string; override; function GetCount: Integer; override; function GetObject(Index: Integer): TObject; override; procedure Put(Index: Integer; const S: string); override; procedure PutObject(Index: Integer; AObject: TObject); override; procedure SetUpdateState(Updating: Boolean); override; public constructor Create; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Delete(Index: Integer); override; procedure Insert(Index: Integer; const S: string); override; procedure Clear; override; end; procedure FreeSection(Section: PHeaderSection); begin if Section <> nil then Dispose(Section); end; function NewSection(const ATitle: string; AWidth: Integer; AObject: TObject): PHeaderSection; begin New(Result); with Result^ do begin Title := ATitle; Width := AWidth; FObject := AObject; end; end; constructor THeaderStrings.Create; begin inherited Create; FList := TList.Create; end; destructor THeaderStrings.Destroy; begin if FList <> nil then begin Clear; FList.Destroy; end; inherited Destroy; end; procedure THeaderStrings.Assign(Source: TPersistent); var I, J: Integer; Strings: TStrings; NewList: TList; Section: PHeaderSection; TempStr: string; Found: Boolean; begin if Source is TStrings then begin Strings := TStrings(Source); BeginUpdate; try NewList := TList.Create; try { Delete any sections not in the new list } I := FList.Count - 1; Found := False; while I >= 0 do begin TempStr := Get(I); for J := 0 to Strings.Count - 1 do begin Found := CompareStr(Strings[J], TempStr) = 0; if Found then Break; end; if not Found then Delete(I); Dec(I); end; { Now iterate over the lists and maintain section widths of sections in the new list } I := 0; for J := 0 to Strings.Count - 1 do begin if (I < FList.Count) and (CompareStr(Strings[J], Get(I)) = 0) then begin Section := NewSection(Get(I), PHeaderSection(FList[I])^.Width, GetObject(I)); Inc(I); end else Section := NewSection(Strings[J], FHeader.Canvas.TextWidth(Strings[J]) + 8, Strings.Objects[J]); NewList.Add(Section); end; Clear; FList.Destroy; FList := NewList; FHeader.Invalidate; except for I := 0 to NewList.Count - 1 do FreeSection(NewList[I]); NewList.Destroy; raise; end; finally EndUpdate; end; Exit; end; inherited Assign(Source); end; procedure THeaderStrings.DefineProperties(Filer: TFiler); begin { This will allow the old file image read in } if Filer is TReader then inherited DefineProperties(Filer); Filer.DefineProperty('Sections', ReadData, WriteData, Count > 0); end; procedure THeaderStrings.Clear; var I: Integer; begin for I := 0 to FList.Count - 1 do FreeSection(FList[I]); FList.Clear; end; procedure THeaderStrings.Delete(Index: Integer); begin FreeSection(FList[Index]); FList.Delete(Index); if FHeader <> nil then FHeader.Invalidate; end; function THeaderStrings.Get(Index: Integer): string; begin Result := PHeaderSection(FList[Index])^.Title; end; function THeaderStrings.GetCount: Integer; begin Result := FList.Count; end; function THeaderStrings.GetObject(Index: Integer): TObject; begin Result := PHeaderSection(FList[Index])^.FObject; end; procedure THeaderStrings.Insert(Index: Integer; const S: string); var Width: Integer; begin if FHeader <> nil then Width := FHeader.Canvas.TextWidth(S) + 8 else Width := DefaultSectionWidth; FList.Expand.Insert(Index, NewSection(S, Width, nil)); if FHeader <> nil then FHeader.Invalidate; end; procedure THeaderStrings.Put(Index: Integer; const S: string); var P: PHeaderSection; Width: Integer; begin P := FList[Index]; if FHeader <> nil then Width := FHeader.Canvas.TextWidth(S) + 8 else Width := DefaultSectionWidth; FList[Index] := NewSection(S, Width, P^.FObject); FreeSection(P); if FHeader <> nil then FHeader.Invalidate; end; procedure THeaderStrings.PutObject(Index: Integer; AObject: TObject); begin PHeaderSection(FList[Index])^.FObject := AObject; if FHeader <> nil then FHeader.Invalidate; end; procedure THeaderStrings.ReadData(Reader: TReader); var Width, I: Integer; Str: string; begin Reader.ReadListBegin; Clear; while not Reader.EndOfList do begin Str := Reader.ReadString; Width := DefaultSectionWidth; I := 1; if Str[1] = #0 then begin repeat Inc(I); until (I > Length(Str)) or (Str[I] = #0); Width := StrToIntDef(Copy(Str, 2, I - 2), DefaultSectionWidth); System.Delete(Str, 1, I); end; FList.Expand.Insert(FList.Count, NewSection(Str, Width, nil)); end; Reader.ReadListEnd; end; procedure THeaderStrings.SetUpdateState(Updating: Boolean); begin if FHeader <> nil then begin SendMessage(FHeader.Handle, WM_SETREDRAW, Ord(not Updating), 0); if not Updating then FHeader.Refresh; end; end; procedure THeaderStrings.WriteData(Writer: TWriter); var I: Integer; HeaderSection: PHeaderSection; begin Writer.WriteListBegin; for I := 0 to Count - 1 do begin HeaderSection := FList[I]; with HeaderSection^ do Writer.WriteString(Format(#0'%d'#0'%s', [Width, Title])); end; Writer.WriteListEnd; end; { THeader } constructor THeader.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csDesignInteractive, csOpaque]; Width := 250; Height := 25; FSections := THeaderStrings.Create; THeaderStrings(FSections).FHeader := Self; FAllowResize := True; FBorderStyle := bsSingle; end; destructor THeader.Destroy; begin FreeSections; FSections.Free; inherited Destroy; end; procedure THeader.CreateParams(var Params: TCreateParams); const BorderStyles: array[TBorderStyle] of Longint = (0, WS_BORDER); begin inherited CreateParams(Params); with Params do begin Style := Style or BorderStyles[FBorderStyle]; WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW); end; end; procedure THeader.Paint; var I, Y, W: Integer; S: string; R: TRect; begin with Canvas do begin Font := Self.Font; Brush.Color := clBtnFace; I := 0; Y := (ClientHeight - Canvas.TextHeight('T')) div 2; R := Rect(0, 0, 0, ClientHeight); W := 0; S := ''; repeat if I < FSections.Count then begin with PHeaderSection(THeaderStrings(FSections).FList[I])^ do begin W := Width; S := Title; end; Inc(I); end; R.Left := R.Right; Inc(R.Right, W); if (ClientWidth - R.Right < 2) or (I = FSections.Count) then R.Right := ClientWidth; TextRect(Rect(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1), R.Left + 3, Y, S); DrawEdge(Canvas.Handle, R, BDR_RAISEDINNER, BF_TOPLEFT); DrawEdge(Canvas.Handle, R, BDR_RAISEDINNER, BF_BOTTOMRight); until R.Right = ClientWidth; end; end; procedure THeader.FreeSections; begin if FSections <> nil then FSections.Clear; end; procedure THeader.SetBorderStyle(Value: TBorderStyle); begin if Value <> FBorderStyle then begin FBorderStyle := Value; RecreateWnd; end; end; procedure THeader.SetSections(Strings: TStrings); begin FSections.Assign(Strings); end; function THeader.GetWidth(X: Integer): Integer; var I, W: Integer; begin if X = FSections.Count - 1 then begin W := 0; for I := 0 to X - 1 do Inc(W, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width); Result := ClientWidth - W; end else if (X >= 0) and (X < FSections.Count) then Result := PHeaderSection(THeaderStrings(FSections).FList[X])^.Width else Result := 0; end; procedure THeader.SetWidth(X: Integer; Value: Integer); begin if X < 0 then Exit; PHeaderSection(THeaderStrings(FSections).FList[X])^.Width := Value; Invalidate; end; procedure THeader.WMNCHitTest(var Msg: TWMNCHitTest); begin inherited; FHitTest := SmallPointToPoint(Msg.Pos); end; procedure THeader.WMSetCursor(var Msg: TWMSetCursor); var Cur: HCURSOR; I: Integer; X: Integer; begin Cur := 0; FResizeSection := 0; FHitTest := ScreenToClient(FHitTest); X := 2; with Msg do if HitTest = HTCLIENT then for I := 0 to FSections.Count - 2 do { don't count last section } begin Inc(X, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width); FMouseOffset := X - (FHitTest.X + 2); if Abs(FMouseOffset) < 4 then begin Cur := LoadCursor(0, IDC_SIZEWE); FResizeSection := I; Break; end; end; FCanResize := (FAllowResize or (csDesigning in ComponentState)) and (Cur <> 0); if FCanResize then SetCursor(Cur) else inherited; end; procedure THeader.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited MouseDown(Button, Shift, X, Y); if ((csDesigning in ComponentState) and (Button = mbRight)) or (Button = mbLeft) then if FCanResize then SetCapture(Handle); end; procedure THeader.MouseMove(Shift: TShiftState; X, Y: Integer); var I: Integer; AbsPos: Integer; MinPos: Integer; MaxPos: Integer; begin inherited MouseMove(Shift, X, Y); if (GetCapture = Handle) and FCanResize then begin { absolute position of this item } AbsPos := 2; for I := 0 to FResizeSection do Inc(AbsPos, PHeaderSection(THeaderStrings(FSections).FList[I])^.Width); if FResizeSection > 0 then MinPos := AbsPos - PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width + 2 else MinPos := 2; MaxPos := ClientWidth - 2; if X < MinPos then X := MinPos; if X > MaxPos then X := MaxPos; Dec(PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width, (AbsPos - X - 2) - FMouseOffset); Sizing(FResizeSection, PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width); Refresh; end; end; procedure THeader.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if FCanResize then begin ReleaseCapture; Sized(FResizeSection, PHeaderSection(THeaderStrings(FSections).FList[FResizeSection])^.Width); FCanResize := False; end; inherited MouseUp(Button, Shift, X, Y); end; procedure THeader.Sizing(ASection, AWidth: Integer); begin if Assigned(FOnSizing) then FOnSizing(Self, ASection, AWidth); end; procedure THeader.Sized(ASection, AWidth: Integer); var Form: TCustomForm; begin if Assigned(FOnSized) then FOnSized(Self, ASection, AWidth); if csDesigning in ComponentState then begin Form := GetParentForm(Self); if Form <> nil then Form.Designer.Modified; end; end; { TGroupButton } type TGroupButton = class(TRadioButton) private FInClick: Boolean; procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; protected procedure ChangeScale(M, D: Integer); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyPress(var Key: Char); override; public constructor InternalCreate(RadioGroup: TCustomRadioGroup); destructor Destroy; override; end; constructor TGroupButton.InternalCreate(RadioGroup: TCustomRadioGroup); begin inherited Create(RadioGroup); RadioGroup.FButtons.Add(Self); Visible := False; Enabled := RadioGroup.Enabled; ParentShowHint := False; OnClick := RadioGroup.ButtonClick; Parent := RadioGroup; end; destructor TGroupButton.Destroy; begin TCustomRadioGroup(Owner).FButtons.Remove(Self); inherited Destroy; end; procedure TGroupButton.CNCommand(var Message: TWMCommand); begin if not FInClick then begin FInClick := True; try if ((Message.NotifyCode = BN_CLICKED) or (Message.NotifyCode = BN_DOUBLECLICKED)) and TCustomRadioGroup(Parent).CanModify then inherited; except Application.HandleException(Self); end; FInClick := False; end; end; procedure TGroupButton.ChangeScale(M, D: Integer); begin end; procedure TGroupButton.KeyPress(var Key: Char); begin inherited KeyPress(Key); TCustomRadioGroup(Parent).KeyPress(Key); if (Key = #8) or (Key = ' ') then begin if not TCustomRadioGroup(Parent).CanModify then Key := #0; end; end; procedure TGroupButton.KeyDown(var Key: Word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); TCustomRadioGroup(Parent).KeyDown(Key, Shift); end; { TCustomRadioGroup } constructor TCustomRadioGroup.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := [csSetCaption, csDoubleClicks]; FButtons := TList.Create; FItems := TStringList.Create; TStringList(FItems).OnChange := ItemsChange; FItemIndex := -1; FColumns := 1; end; destructor TCustomRadioGroup.Destroy; begin SetButtonCount(0); TStringList(FItems).OnChange := nil; FItems.Free; FButtons.Free; inherited Destroy; end; procedure TCustomRadioGroup.ArrangeButtons; var ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer; DC: HDC; SaveFont: HFont; Metrics: TTextMetric; DeferHandle: THandle; begin if (FButtons.Count <> 0) and not FReading then begin DC := GetDC(0); SaveFont := SelectObject(DC, Font.Handle); GetTextMetrics(DC, Metrics); SelectObject(DC, SaveFont); ReleaseDC(0, DC); ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns; ButtonWidth := (Width - 10) div FColumns; I := Height - Metrics.tmHeight - 5; ButtonHeight := I div ButtonsPerCol; TopMargin := Metrics.tmHeight + 1 + (I mod ButtonsPerCol) div 2; DeferHandle := BeginDeferWindowPos(FButtons.Count); for I := 0 to FButtons.Count - 1 do with TGroupButton(FButtons[I]) do begin DeferHandle := DeferWindowPos(DeferHandle, Handle, 0, (I div ButtonsPerCol) * ButtonWidth + 8, (I mod ButtonsPerCol) * ButtonHeight + TopMargin, ButtonWidth, ButtonHeight, SWP_NOZORDER or SWP_NOACTIVATE); Visible := True; end; EndDeferWindowPos(DeferHandle); end; end; procedure TCustomRadioGroup.ButtonClick(Sender: TObject); begin if not FUpdating then begin FItemIndex := FButtons.IndexOf(Sender); Changed; Click; end; end; procedure TCustomRadioGroup.ItemsChange(Sender: TObject); begin if not FReading then begin if FItemIndex >= FItems.Count then FItemIndex := FItems.Count - 1; UpdateButtons; end; end; procedure TCustomRadioGroup.ReadState(Reader: TReader); begin FReading := True; inherited ReadState(Reader); FReading := False; UpdateButtons; end; procedure TCustomRadioGroup.SetButtonCount(Value: Integer); begin while FButtons.Count < Value do TGroupButton.InternalCreate(Self); while FButtons.Count > Value do TGroupButton(FButtons.Last).Free; end; procedure TCustomRadioGroup.SetColumns(Value: Integer); begin if Value < 1 then Value := 1; if Value > 16 then Value := 16; if FColumns <> Value then begin FColumns := Value; ArrangeButtons; end; end; procedure TCustomRadioGroup.SetItemIndex(Value: Integer); begin if FReading then FItemIndex := Value else begin if Value < -1 then Value := -1; if Value >= FButtons.Count then Value := FButtons.Count - 1; if FItemIndex <> Value then begin if FItemIndex >= 0 then TGroupButton(FButtons[FItemIndex]).Checked := False; FItemIndex := Value; if FItemIndex >= 0 then TGroupButton(FButtons[FItemIndex]).Checked := True; end; end; end; procedure TCustomRadioGroup.SetItems(Value: TStrings); begin FItems.Assign(Value); end; procedure TCustomRadioGroup.UpdateButtons; var I: Integer; begin SetButtonCount(FItems.Count); for I := 0 to FButtons.Count - 1 do TGroupButton(FButtons[I]).Caption := FItems[I]; if FItemIndex >= 0 then begin FUpdating := True; TGroupButton(FButtons[FItemIndex]).Checked := True; FUpdating := False; end; ArrangeButtons; Invalidate; end; procedure TCustomRadioGroup.CMEnabledChanged(var Message: TMessage); var I: Integer; begin inherited; for I := 0 to FButtons.Count - 1 do TGroupButton(FButtons[I]).Enabled := Enabled; end; procedure TCustomRadioGroup.CMFontChanged(var Message: TMessage); begin inherited; ArrangeButtons; end; procedure TCustomRadioGroup.WMSize(var Message: TWMSize); begin inherited; ArrangeButtons; end; function TCustomRadioGroup.CanModify: Boolean; begin Result := True; end; procedure TCustomRadioGroup.GetChildren(Proc: TGetChildProc; Root: TComponent); begin end; type THack = class(TWinControl); { TSplitter } constructor TSplitter.Create(AOwner: TComponent); begin inherited Create(AOwner); Align := alLeft; Width := 3; Cursor := crHSplit; FMinSize := 30; FBeveled := True; end; procedure TSplitter.AllocateLineDC; begin FLineDC := GetDCEx(Parent.Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE); end; procedure TSplitter.DrawLine; var P: TPoint; begin FLineVisible := not FLineVisible; P := Point(Left, Top); if Align in [alLeft, alRight] then P.X := Left + FSplit else P.Y := Top + FSplit; with P do PatBlt(FLineDC, X, Y, Width, Height, PATINVERT); end; procedure TSplitter.ReleaseLineDC; begin ReleaseDC(Parent.Handle, FLineDC); end; procedure TSplitter.Paint; var FrameBrush: HBRUSH; R: TRect; begin R := ClientRect; Canvas.Brush.Color := Color; Canvas.FillRect(ClientRect); if Beveled then begin if Align in [alLeft, alRight] then InflateRect(R, -1, 2) else InflateRect(R, 2, -1); OffsetRect(R, 1, 1); FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight)); FrameRect(Canvas.Handle, R, FrameBrush); DeleteObject(FrameBrush); OffsetRect(R, -2, -2); FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow)); FrameRect(Canvas.Handle, R, FrameBrush); DeleteObject(FrameBrush); end; end; procedure TSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); function FindControl: TControl; var P: TPoint; I: Integer; begin Result := nil; P := Point(Left, Top); case Align of alLeft: Dec(P.X); alRight: Inc(P.X, Width); alTop: Dec(P.Y); alBottom: Inc(P.Y, Height); else Exit; end; for I := 0 to Parent.ControlCount - 1 do begin Result := Parent.Controls[I]; if PtInRect(Result.BoundsRect, P) then Exit; end; Result := nil; end; var I: Integer; begin inherited; if Button = mbLeft then begin FControl := FindControl; FDownPos := Point(X, Y); if Assigned(FControl) then begin if Align in [alLeft, alRight] then begin FMaxSize := Parent.ClientWidth - FMinSize; for I := 0 to Parent.ControlCount - 1 do with Parent.Controls[I] do if Align in [alLeft, alRight] then Dec(FMaxSize, Width); Inc(FMaxSize, FControl.Width); end else begin FMaxSize := Parent.ClientHeight - FMinSize; for I := 0 to Parent.ControlCount - 1 do with Parent.Controls[I] do if Align in [alTop, alBottom] then Dec(FMaxSize, Height); Inc(FMaxSize, FControl.Height); end; UpdateSize(X, Y); AllocateLineDC; with ValidParentForm(Self) do if ActiveControl <> nil then begin FActiveControl := ActiveControl; FOldKeyDown := THack(FActiveControl).OnKeyDown; THack(FActiveControl).OnKeyDown := FocusKeyDown; end; DrawLine; end; end; end; procedure TSplitter.UpdateSize(X, Y: Integer); var S: Integer; begin if Align in [alLeft, alRight] then FSplit := X - FDownPos.X else FSplit := Y - FDownPos.Y; S := 0; case Align of alLeft: S := FControl.Width + FSplit; alRight: S := FControl.Width - FSplit; alTop: S := FControl.Height + FSplit; alBottom: S := FControl.Height - FSplit; end; FNewSize := S; if S < FMinSize then FNewSize := FMinSize else if S > FMaxSize then FNewSize := FMaxSize; if S <> FNewSize then begin if Align in [alRight, alBottom] then S := S - FNewSize else S := FNewSize - S; Inc(FSplit, S); end; end; procedure TSplitter.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; if Assigned(FControl) then begin DrawLine; UpdateSize(X, Y); DrawLine; end; end; procedure TSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; if Assigned(FControl) then begin DrawLine; case Align of alLeft: FControl.Width := FNewSize; alTop: FControl.Height := FNewSize; alRight: begin Parent.DisableAlign; try FControl.Left := FControl.Left + (FControl.Width - FNewSize); FControl.Width := FNewSize; finally Parent.EnableAlign; end; end; alBottom: begin Parent.DisableAlign; try FControl.Top := FControl.Top + (FControl.Height - FNewSize); FControl.Height := FNewSize; finally Parent.EnableAlign; end; end; end; StopSizing; end; end; procedure TSplitter.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_ESCAPE then StopSizing else if Assigned(FOldKeyDown) then FOldKeyDown(Sender, Key, Shift); end; procedure TSplitter.SetBeveled(Value: Boolean); begin FBeveled := Value; Repaint; end; procedure TSplitter.StopSizing; begin if Assigned(FControl) then begin if FLineVisible then DrawLine; FControl := nil; ReleaseLineDC; if Assigned(FActiveControl) then begin THack(FActiveControl).OnKeyDown := FOldKeyDown; FActiveControl := nil; end; end; if Assigned(FOnMoved) then FOnMoved(Self); end; end.